COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 A Metering System for MacLisp
C00013 00003	 If you say (array foo fixnum a b c)
C00015 ENDMK
C⊗;
;;; A Metering System for MacLisp

(declare (special meter:meters meter:max meter:comments meter:meterp
		  meter:maxf))

(eval-when (compile eval)
	   (setq meter:meters ()))

(eval-when (load)
	   (cond ((boundp 'meter:meters))
		 (t (setq meter:meters ()))))

;;; (meter (defun foo ... (m "Baz"))...)
;;; (m "Foo")
;;; (m "Foo" 3)
;;; (m "Foo" 3 (foo a b c))
;;; (mn "Foo" foo)
;;; (mn "Foo" foo 3)
;;; (mn "Foo" foo 3 (foo a b c))

;;; (meter-funs
;;;  ((zerop "Zerop")(1- "1-") (* "Times")(PUSH "CONSs" CONS 2))
;;; 		  (defun fact (n)			 ↑   ↑ 
;;; 			 (cond ((zerop n) 1)		optionals
;;; 			       (t (* n (fact (1- n)))))))

;;; THE LAST FORM MUST BE:
;;;	(METER:INIT)

(defmacro meter-funs (funs . functions)
	  `(meter . ,(mapcar #'(lambda (f) 
				       `(defun ,(cadr f) ,(caddr f)
					       .,(meter:meter-funs funs 
								  (cdddr f))))
			     functions)))

(defmacro meter functions
	  (cond ((and (boundp 'meter:meterp)
		      (not meter:meterp))
		 `(progn 'compile
			 . ,(mapcar #'meter:unprocess functions)))
		(t 
		 (let* ((name (cadr (car functions)))
			(array-name (implode (append (explode name) 
						     '(- a r r a y)))) 
			(comment-array-name (implode (append (explode name)
							     '(- c o m m e n t))))
			(init-name (implode (append (explode name)
						    '(- i n i t))))
			(meter:max -1)
			(meter:maxf -1)
			(meter:comments ()))
		       `(progn 'compile
			       (declare (array* (fixnum ,array-name 1 
							,time-array-name 1)
						(notype ,comment-array-name 1)))
			       ,@(mapcar #'(lambda (f)
						   `(defun
						     ,(cadr f)
						     ,(caddr f)
						     .,(meter:process 
							array-name 
							(cdddr f))))
					 functions)
			       ,@(progn
				  (let ((entry (assq name meter:meters)))
				       (cond (entry (rplaca (cdddr entry) meter:max))
					     (t 
					      (push 
					       `(,name ,array-name ,comment-array-name ,meter:max)
					       meter:meters))))
				  ())
			       (defun ,init-name () (fillarray ',array-name '(0))
				      (fillarray ',time-array-name '(0))
				      (meter:init-time (get ',array-name
							    'array)) )
			       (array ,comment-array-name t ,(1+ meter:max))
			       (fillarray ',comment-array-name 
					  (quote ,(reverse 
						   (mapcar #'cadr
							   meter:comments))))
			       (array ,array-name fixnum ,(1+ meter:max))
			       (array ,time-array-name fixnum ,(1+ meter:max))
			       (setq meter:meters ',meter:meters)
			       (,init-name)
			       ',name))))) 

(defun meter:meter-funs (l f)
       (cond ((null f) ())
	     ((atom f) f)
	     ((numberp f) f)
	     (t (let ((entry (assq (car f) l)))
		     (cond (entry
			    `(mn ,(cadr entry) ,(or (caddr entry)
						    (car entry))
				 ,(or (cadddr entry) 1)
				 (,(car f) ,@(mapcar #'(lambda(f)
							  (meter:meter-funs l f))
						       (cdr f)))))
			   (t (mapcar #'(lambda(f)
					 (meter:meter-funs l f))
				      f)))))))
	     
(defun meter:process (a f)
       (cond ((null f) ())
	     ((atom f) f)
	     ((numberp f) f)
	     ((eq (car f) 'm)
	      (let* ((form ())
		     (inc (cond ((null (cddr f)) 1)
				((null (cdddr f))
				 (caddr f))
				(t 
				 (setq form (cadddr f))
				 (caddr f))))
		     (result
		      (progn
		       (setq meter:max (1+ meter:max))
		       (push `(() ,(cadr f) 
				  . ,meter:max)
			     meter:comments)
		       `(store 
			 (,a ,meter:max) 
			 (+ ,inc (,a ,meter:max))))))
		    (cond (form
			   `(progn ,result 
				   (prog2 (meter:time1) ,(meter:process a form)
					  (meter:time2 ,meter:max))))
			  (t result))))
	     ((eq (car f) 'mn)
	      (let* ((index (caddr f))
		     (entry (assq index meter:comments))
		     (form ())
		     (inc (cond ((null (cdddr f)) 1)
				((null (cdr (cdddr f)))
				 (caddr (cdr f)))
				(t 
				 (setq form (cadddr (cdr f)))
				 (caddr (cdr f)))))
		     (result
		      (cond (entry 
			     `(store (,a ,(cddr entry))
				     (+ ,inc (,a ,(cddr entry)))))
			    (t (setq meter:max (1+ meter:max))
			       (push `(,index ,(cadr f) 
					      . ,meter:max)
				     meter:comments)
			       `(store 
				 (,a ,meter:max) 
				 (+ ,inc (,a ,meter:max)))))))
		    (cond (form
			   `(progn ,result 
				   (prog2 (meter:time1) ,(meter:process a form)
					  (meter:time2 ,meter:max))))
			  (t result))))
	     (t (mapcar #'(lambda (f) (meter:process a f))
			f))))

(defun meter:unprocess (f)
       (cond ((null f) ())
	     ((atom f) f)
	     ((numberp f) f)
	     ((atom (car f))
	      `(,(car f) . ,(meter:unprocess (cdr f))))
	     ((eq (caar f) 'm)
	      (let ((form 
		      (cond ((null (cddr (car f))) ())
			    ((null (cdddr (car f)))
				 ())
			    (t 
			     (cadddr (car f)))))) 
		   (cond (form `(,(meter:unprocess form)
				 .,(meter:unprocess (cdr f))))
			 (t (meter:unprocess (cdr f))))))
	     ((eq (caar f) 'mn)
	      (let ((form
		     (cond ((null (cdddr (car f))) ())
			   ((null (cdr (cdddr (car f))))
			    ())
			   (t 
			    (cadddr (cdr (car f)))))))
		   (cond (form `(,(meter:unprocess form)
				 .,(meter:unprocess (cdr f))))
			 (t (meter:unprocess (cdr f))))))
	     (t `(,(meter:unprocess (car f))
		  . ,(meter:unprocess (cdr f))))))

(defun meter:report (&optional (name ()))
 (declare (flonum total-ops))
 (terpri)
 (princ '|Statistics|)
 (terpri)
 (do ((l (cond ((null name) meter:meters)
	       (t (let ((entry (assq name meter:meters)))
		       (cond (entry (ncons entry))
			     (t ())))))
	 (cdr l)))
     ((null l) t)
     (terpri)
     (princ '|Meter for: |)
     (princ (car (car l)))
     (terpri)
     (let ((ar1 (get (cadr (car l)) 'array))
	   (ar2 (get (caddr (car l)) 'array))
	   (total-ops 0.0)
	   (max (cadddr (car l))))
	  (do ((n 0 (1+ n))
	       (total (arraycall t ar1 0) (+ total (arraycall fixnum ar1 n))))
	      ((> n max) (setq total-ops (float total))))
	  (do ((n 0 (1+ n)))
	      ((> n max) (princ '|Total = |)(princ (fix total-ops))
			 (terpri))
	      (princ (arraycall t ar2 n))
	      (princ '| = |)
	      (let ((x (arraycall fixnum ar1 n)))
		   (princ x)
		   (princ '| (|)
		   (princ (//$ 
			   (float 
			    (fix 
			     (*$ 10000.0 
				 (+$ .00005
				     (//$ (float x)
					  total-ops))))) 
			   100.0))
		   (princ '|%)|))
	      (terpri)))))

(defun meter:init-time (ar n)
       (meter:init-time1 (maknum (get ar 'array))))
;;; If you say (array foo fixnum a b c)
;;; (meter:init-time1 (maknum (get 'foo 'array)) b c)

(lap meter:init-time1 subr)
(args meter:init-time1 (nil . 3))
	(setzm 0 count)
 	(hrrz a 0 a)	;get address
	(hrrz tt 0 a)
	(hrrzi tt 4 tt)	;business address
	(aos 0 tt)
	(movem tt array)
	(move tt 0 c)
	(movem tt factor1)
	(imul tt 0 c)	;multiply it
	(movem tt factor2)
	(movei a 't)
	(popj p)

;;; (meter:time1)
(entry meter:time1 subr)
(args meter:time1 (nil . 0))
	(movei tt 0)
	(calli tt #o27)
	(movem tt count)
	(movei a 't)
	(popj p)

;;; (meter:time2 <function-number> <meter-number> <increment>)
(entry meter:time2 subr)
(args meter:time2 (nil . 3))
	(movei tt 0)
	(calli tt #o27)
	(sub tt count)
	(move t 0 a)	;get function-number
	(imul t factor1)
	(move r 0 b)	;get meter-number
	(imul r factor2)
	(add t r)	;store the increment in the 0th position
	(add t array)
	(move c 0 c)	
	(addm c 0 t)	;increment
	(addm tt 1 t)	;add the runtime
	(popj p)	;return the function-number

count (0)
array (0)
factor1 (0)
factor2 (0)
()